home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / xscm.lha / xscm / xmsubs.scm < prev    next >
Encoding:
Text File  |  1992-08-29  |  7.8 KB  |  239 lines
  1. ; $Header: /home/campbell/Languages/Scheme/scm/x-scm/RCS/xmsubs.scm,v 1.5 1992/07/26 21:29:14 campbell Beta $
  2. ;
  3. ; Generally useful Motif functions.  These are EXTREMELY subject to 
  4. ; change.  I intend to try to create more-or-less toolkit-independent
  5. ; versions of these, so that I can build compatible versions for
  6. ; OpenLook, Microsoft Windows, Macintosh, etc.  So be prepared for
  7. ; these interfaces to change...  -lc
  8. ;
  9. ;  Author: Larry Campbell (campbell@redsox.bsw.com)
  10. ; 
  11. ;  Copyright 1992 by The Boston Software Works, Inc.
  12. ;  Permission to use for any purpose whatsoever granted, as long
  13. ;  as this copyright notice remains intact.  Please send bug fixes
  14. ;  or enhancements to the above email address.
  15.  
  16. (require (in-vicinity (library-vicinity) "assert.scm"))
  17.  
  18. ; Call a thunk with a "busy" cursor (watch, hourglass, glacier...)
  19. ;
  20. (define (with-busy-cursor widget thunk)
  21.   (if (xt:is-realized widget)
  22.       (let ((xdisplay (xt:display widget))
  23.         (xwindow (xt:window widget)))
  24.     (x:define-cursor xdisplay xwindow xc:watch)
  25.     (x:flush xdisplay)
  26.     (apply thunk '())
  27.     (x:undefine-cursor xdisplay xwindow))
  28.       (apply thunk '())))
  29.  
  30. ; Create a text widget with a caption to its left.  Returns the
  31. ; text widget's ID.
  32. ;
  33. (define (make-captioned-text-widget parent label columns . args)
  34.   #.(assert '(string? label))
  35.   #.(assert '(integer? columns))
  36.   (let* ((rc (xt:create-managed-widget
  37.           "ct" xm:form parent))
  38.      (caption (xt:create-managed-widget
  39.            "caption" xm:label-gadget rc
  40.            xm:n-label-string (xm:string-create label)))
  41.      (text (xt:create-managed-widget
  42.         "text" xm:text-field rc
  43.         xm:n-columns columns))
  44.      (offset (+
  45.           (xt:get-value text xm:n-shadow-thickness xt:integer)
  46.           (xt:get-value text xm:n-highlight-thickness xt:integer)
  47.           (xt:get-value text xm:n-margin-height xt:integer))))
  48.     (xt:set-values
  49.      caption
  50.      xm:n-margin-height offset
  51.      xm:n-right-attachment xm:attach-widget
  52.      xm:n-bottom-attachment xm:attach-form
  53.      xm:n-right-widget text)
  54.     (xt:set-values
  55.      text
  56.      xm:n-right-attachment xm:attach-form
  57.      xm:n-bottom-attachment xm:attach-form
  58.      xm:n-right-widget text)
  59.     text))
  60.  
  61. (define (popup-error parent message)
  62.   #.(assert '(string? message))
  63.   (let* ((dshell (xt:create-popup-shell
  64.           "Error" xm:dialog-shell parent))
  65.      (mshell (xt:create-managed-widget
  66.           "Error" xm:message-box dshell
  67.           xm:n-dialog-type xm:dialog-error
  68.           xm:n-message-string (xm:string-create message))))
  69.     (xt:add-callback
  70.      mshell
  71.      xm:n-ok-callback (lambda (w) (xt:destroy-widget dshell)))
  72.     (xt:popup dshell 1)))
  73.  
  74. (define (popup-information parent message)
  75.   #.(assert '(string? message))
  76.   (let* ((dshell (xt:create-popup-shell
  77.           "Information" xm:dialog-shell parent))
  78.      (mshell (xt:create-managed-widget
  79.           "Information" xm:message-box dshell
  80.           xm:n-dialog-type xm:dialog-information
  81.           xm:n-message-string (xm:string-create message))))
  82.     (xt:add-callback
  83.      mshell
  84.      xm:n-ok-callback (lambda (w) (xt:destroy-widget dshell)))
  85.     (xt:popup dshell 1)))
  86.  
  87.  
  88. ; Create a row of evenly-spaced buttons (typically used for the
  89. ; "OK" "Apply" "Cancel" buttons at the bottom of a panel).
  90. ; Returns nothing.
  91. ; 
  92. ; Usage:
  93. ;   (make-button-row parent '(("label 1" action1) ("label 2" action2)))
  94. ;
  95. (define (make-button-row parent button-specifiers)
  96.   #.(assert '(list? button-specifiers))
  97.   (let ((rc (xt:create-managed-widget
  98.          "rc" xm:row-column parent
  99.          xm:n-orientation xm:horizontal
  100.          xm:n-packing xm:pack-column))
  101.     (parent-width (xt:get-value parent xt:n-width xt:integer)))
  102.     (if (=? 0 parent-width)
  103.     (error "button-row: parent has zero width"))
  104.     (do ((items button-specifiers (cdr items)))
  105.     ((null? items) rc)
  106.       (let* ((item (car items))
  107.          (label (car item))
  108.          (action (cadr item))
  109.          (others (cddr item)))
  110.     (apply make-button `(,label ,rc ,action ,@others))))))
  111.  
  112.  
  113. (define (make-button label parent action . args)
  114. ;;
  115. ;; Make a button.  If <action> is a list, the button pops up a pulldown
  116. ;; menu, and <action> is the argument list for make-pulldown-menu.
  117. ;; If <label> begins with a question mark, the question mark is removed,
  118. ;; and the button is a toggle button.
  119. ;;
  120.   #.(assert '(or (symbol? label) (string? label)))
  121.   #.(assert
  122.      '(or
  123.        (procedure? action)
  124.        (list? action))
  125.      'action)
  126.   (let ((widget '())
  127.     (widget-callback (if (null? args) args (car args)))
  128.     (args (if (null? args) args (cdr args)))
  129.     (class '())
  130.     (callback xm:n-activate-callback))
  131.     (set! widget
  132.       (if (list? action)
  133.           (apply make-pulldown-menu `(,label ,parent ,@action))
  134.           (begin
  135.         (case label
  136.           ((xm:arrow-up xm:arrow-down xm:arrow-left xm:arrow-right)
  137.            (set! widget
  138.              (xt:create-managed-widget
  139.               "button" xm:arrow-button-gadget parent
  140.               xm:n-arrow-direction
  141.               (case label
  142.                 ((xm:arrow-down) xm:arrow-down)
  143.                 ((xm:arrow-up) xm:arrow-up)
  144.                 ((xm:arrow-left) xm:arrow-left)
  145.                 ((xm:arrow-right) xm:arrow-right))
  146.               xm:n-traversal-on #f)))
  147.  
  148.           (else
  149.            (let ((class xm:push-button-gadget))
  150.              (if (char=? (string-ref label 0) #\?)
  151.              (begin
  152.                (set! class xm:toggle-button-gadget)
  153.                (set! callback xm:n-value-changed-callback)
  154.                (set! label
  155.                  (substring label 1 (string-length label)))))
  156.              (set! widget
  157.                (xt:create-managed-widget
  158.                 label class parent
  159.                 xm:n-alignment xm:alignment-center
  160.                 xm:n-shadow-thickness 2)))))
  161.         (xt:add-callback widget callback action)
  162.         (or (null? args)
  163.             (apply xt:set-values `(,widget ,@args)))
  164.         widget)))
  165.     (if (not (null? widget-callback))
  166.     (widget-callback widget))
  167.     widget))
  168.  
  169. (define (make-toggle-button label parent action . resources)
  170.   #.(assert '(string? label))
  171.   #.(assert '(procedure? action))
  172.   (let ((widget
  173.      (apply xt:create-managed-widget
  174.       `(,label
  175.         ,xm:toggle-button-gadget
  176.         ,parent
  177.         ,@resources))))
  178.     (xt:add-callback widget xm:n-value-changed-callback action)
  179.     widget))
  180.  
  181. ; (make-popup-menu name parent (label1 action1) (label2 action2)...)
  182. ;
  183. (define (make-popup-menu name parent . args)
  184.   (let* ((widget (xm:create-popup-menu parent name)))
  185.     (xt:create-managed-widget name xm:label-gadget widget)
  186.     (xt:create-managed-widget name xm:separator-gadget widget)
  187.     (do ((items args (cdr items)))
  188.     ((null? items) widget)
  189.         (let* ((item (car items))
  190.                   (label (car item))
  191.            (action (cadr item)))
  192.       (make-button label widget action)))))
  193.  
  194. ; (make-pulldown-menu name parent (label1 action1 wc) (label2 action2 wc)...)
  195. ;
  196. ; wc is an optional argument -- if present, it must be a procedure
  197. ; of one argument which is called with the widget representing the
  198. ; button created.
  199. ;
  200. (define (make-pulldown-menu name parent . args)
  201.   #.(assert '(string? name) 'name 'args)
  202.   #.(assert '(< 1 (length args)) 'name 'args)
  203.   (let* ((mbutton (xt:create-managed-widget
  204.            name xm:cascade-button-gadget parent))
  205.      (menu-pane (xm:create-pulldown-menu parent name)))
  206.     (xt:set-values mbutton xm:n-sub-menu-id menu-pane)
  207.     (do ((items args (cdr items)))
  208.     ((null? items) mbutton)
  209.       (let* ((item (car items))
  210.          (label (car item))
  211.          (action (cadr item))
  212.          (widget-callback
  213.           (if (= 3 (length item))
  214.           (list-ref item 2)
  215.           '())))
  216.     (make-button label menu-pane action widget-callback)))))
  217.  
  218. ; (make-menu-bar parent name ((menu1-title ((label action) ...)) ...)
  219. ;
  220. (define (make-menu-bar parent name . args)
  221.   #.(assert '(string? name) 'name 'args)
  222.   #.(assert '(< 1 (length args)) 'name 'args)
  223.   (let ((menubar (xt:create-managed-widget
  224.           name xm:row-column parent
  225.           xm:n-row-column-type xm:menu-bar)))
  226.     (do ((items args (cdr items)))
  227.     ((null? items) menubar)
  228.       (let* ((item (car items))
  229.          (menu-title (car item))
  230.          (menu-items (cadr item))
  231.          (widget ()))
  232.     (set! widget (apply
  233.               make-pulldown-menu
  234.               `(,menu-title
  235.             ,menubar
  236.             ,@menu-items)))
  237.     (if (equal? menu-title "Help")
  238.         (xt:set-values menubar xm:n-menu-help-widget widget))))))
  239.